home *** CD-ROM | disk | FTP | other *** search
/ Aminet 4 / Aminet 4 - November 1994.iso / aminet / dev / obero / oberon_lib.lha / oberon-a / source1.lha / source / ProjectOberon / Texts.mod < prev   
Text File  |  1994-08-08  |  25KB  |  898 lines
  1. (***************************************************************************
  2.  
  3.      $RCSfile: Texts.mod $
  4.   Description: A port of the Project Oberon Texts module
  5.  
  6.    Created by: J. Gutknecht
  7.     Ported by: fjc (Frank Copeland)
  8.     $Revision: 1.3 $
  9.       $Author: fjc $
  10.         $Date: 1994/08/08 16:42:00 $
  11.  
  12.   Copyright © 1990-1993, ETH Zuerich
  13.   Copyright © 1994, Frank Copeland.
  14.   This file is part of the Oberon-A Library.
  15.   See Oberon-A.doc for conditions of use and distribution.
  16.  
  17.   Log entries are at the end of the file.
  18.  
  19. ***************************************************************************)
  20.  
  21. MODULE Texts;
  22.  
  23. (*
  24. ** $C= CaseChk       $I= IndexChk  $L= LongAdr   $N= NilChk
  25. ** $P= PortableCode  $R= RangeChk  $S= StackChk  $T= TypeChk
  26. ** $V= OvflChk       $Z= ZeroVars
  27. *)
  28.  
  29. IMPORT Files, Fonts, Reals, SYS := SYSTEM;
  30.  
  31. CONST
  32.  
  33.   (* symbol classes *)
  34.  
  35.   Inval *    = 0; (* invalid symbol *)
  36.   Name *     = 1; (* name s (length len) *)
  37.   String *   = 2; (* literal string s (length len) *)
  38.   Int *      = 3; (* integer i (decimal or hexadecimal) *)
  39.   Real *     = 4; (* real number x *)
  40.   LongReal * = 5; (* long real number y *)
  41.   Char *     = 6; (* special character c *)
  42.  
  43.   TAB = 9X; CR = 0DX; maxD = 9;
  44.   LF = 0AX; (* Amiga end-of-line character *)
  45.  
  46.   (* TextBlock = TextBlock off run {run} 0 len {AsciiCode}.
  47.      run = fnt [name] col voff len. *)
  48.  
  49.   TextBlockId = 1FFH;
  50.  
  51.   replace * = 0; insert * = 1; delete * = 2; (* op-codes *)
  52.  
  53. TYPE
  54.  
  55.   Piece = POINTER TO PieceDesc;
  56.   PieceDesc = RECORD
  57.     f     : Files.File;
  58.     off   : LONGINT;
  59.     len   : LONGINT;
  60.     fnt   : Fonts.Font;
  61.     col   : SHORTINT;
  62.     voff  : SHORTINT;
  63.     prev,
  64.     next  : Piece
  65.   END; (* PieceDesc *)
  66.  
  67.   Text * = POINTER TO TextDesc;
  68.  
  69.   Notifier * = PROCEDURE (T : Text; op : INTEGER; beg, end : LONGINT);
  70.  
  71.   TextDesc * = RECORD
  72.     len *    : LONGINT;
  73.     notify * : Notifier;
  74.     trailer  : Piece;
  75.     org      : LONGINT; (* cache *)
  76.     pce      : Piece;
  77.     f        : Files.File (* Holds handle for file opened by Open(). *)
  78.   END; (* TextDesc *)
  79.  
  80.   Reader * = RECORD (Files.Rider)
  81.     eot *  : BOOLEAN;
  82.     fnt *  : Fonts.Font;
  83.     col *  : SHORTINT;
  84.     voff * : SHORTINT;
  85.     ref    : Piece;
  86.     org    : LONGINT;
  87.     off    : LONGINT
  88.   END; (* Reader *)
  89.  
  90.   Scanner * = RECORD (Reader)
  91.     nextCh * : CHAR;
  92.     line *   : INTEGER;
  93.     class *  : INTEGER;
  94.     i *      : LONGINT;
  95.     x *      : REAL;
  96.     y *      : LONGREAL;
  97.     c *      : CHAR;
  98.     len *    : SHORTINT;
  99.     s *      : ARRAY 32 OF CHAR
  100.   END; (* Scanner *)
  101.  
  102.   Buffer * = POINTER TO BufDesc;
  103.   BufDesc * = RECORD
  104.     len *   : LONGINT;
  105.     header,
  106.     last    : Piece
  107.   END; (* BufDesc *)
  108.  
  109.   Writer * = RECORD (Files.Rider)
  110.     buf *  : Buffer;
  111.     fnt *  : Fonts.Font;
  112.     col *  : SHORTINT;
  113.     voff * : SHORTINT
  114.   END; (* Writer *)
  115.  
  116. VAR
  117.   W : Writer; WFile : Files.File; DelBuf : Buffer;
  118.  
  119. (*------------------------------------*)
  120. PROCEDURE ReadName ( VAR R : Files.Rider; VAR name : ARRAY OF CHAR );
  121.  
  122.   VAR i : INTEGER; ch : CHAR;
  123.  
  124. BEGIN (* ReadName *)
  125.   i := 0; Files.Read (R, ch); IF ch = LF THEN ch := CR END;
  126.   WHILE ch # 0X DO
  127.     name [i] := ch; INC (i); Files.Read (R, ch);
  128.     IF ch = LF THEN ch := CR END
  129.   END; (* WHILE *)
  130.   name [i] := 0X
  131. END ReadName;
  132.  
  133. (*------------------------------------*)
  134. PROCEDURE WriteName ( VAR W : Files.Rider; VAR name : ARRAY OF CHAR );
  135.  
  136.   VAR i : INTEGER; ch : CHAR;
  137.  
  138. BEGIN (* WriteName *)
  139.   i := 0; ch := name [i];
  140.   WHILE ch # 0X DO
  141.     Files.Write (W, ch); INC (i); ch := name [i]
  142.   END; (* WHILE *)
  143.   Files.Write (W, 0X)
  144. END WriteName;
  145.  
  146. (*------------------------------------*)
  147. PROCEDURE Load *
  148.   ( T       : Text;
  149.     f       : Files.File;
  150.     pos     : LONGINT;
  151.     VAR len : LONGINT);
  152.  
  153.   VAR
  154.     R       : Files.Rider;
  155.     Q, q, p : Piece;
  156.     off     : LONGINT;
  157.     N, fnt  : SHORTINT;
  158.     FName   : ARRAY 32 OF CHAR;
  159.     Dict    : ARRAY 32 OF Fonts.Font;
  160.  
  161. BEGIN (* Load *)
  162.   N := 1;
  163.   NEW (Q);
  164.   Q.f := WFile; Q.off := 0; Q.len := 1; Q.fnt := NIL; Q.col := 0;
  165.   Q.voff := 0; p := Q;
  166.   Files.Set (R, f, pos); Files.ReadBytes (R, off, SIZE (LONGINT));
  167.   LOOP
  168.     Files.Read (R, fnt);
  169.     IF fnt = 0 THEN EXIT END;
  170.     IF fnt = N THEN
  171.       ReadName (R, FName);
  172.       Dict [N] := Fonts.This (FName);
  173.       INC (N)
  174.     END; (* IF *)
  175.     NEW (q);
  176.     q.fnt := Dict [fnt];
  177.     Files.Read (R, q.col);
  178.     Files.Read (R, q.voff);
  179.     Files.ReadBytes (R, q.len, SIZE (LONGINT));
  180.     q.f := f; q.off := off;
  181.     off := off + q.len;
  182.     p.next := q; q.prev := p; p := q
  183.   END; (* LOOP *)
  184.   p.next := Q; Q.prev := p;
  185.   T.trailer := Q; Files.ReadBytes (R, T.len, SIZE (LONGINT));
  186.   T.org := -1; T.pce := T.trailer; (* init cache *)
  187.   len := off - pos
  188. END Load;
  189.  
  190. (*------------------------------------*)
  191. (* $D- disable copying of open arrays *)
  192. PROCEDURE Open * ( T : Text; name : ARRAY OF CHAR );
  193.  
  194.   VAR
  195.     f    : Files.File;
  196.     R    : Files.Rider;
  197.     Q, q : Piece;
  198.     id   : INTEGER;
  199.     len  : LONGINT;
  200.  
  201. BEGIN (* Open *)
  202.   T.f := NIL; f := Files.Old (name);
  203.   IF f # NIL THEN
  204.     Files.Set (R, f, 0); Files.ReadBytes (R, id, SIZE (INTEGER));
  205.     IF id = TextBlockId THEN
  206.       Load (T, f, 2, len)
  207.     ELSE (* Ascii file *)
  208.       len := Files.Length (f);
  209.       NEW (Q);
  210.       Q.fnt := NIL; Q.col := 0; Q.voff := 0; Q.f := WFile;
  211.       Q.off := 0; Q.len := 1;
  212.       NEW (q);
  213.       q.fnt := Fonts.Default; q.col := 1; q.voff := 0; q.f := f;
  214.       q.off := 0; q.len := len;
  215.       Q.next := q; q.prev := Q; q.next := Q; Q.prev := q;
  216.       T.trailer := Q; T.len := len;
  217.       T.org := -1; T.pce := T.trailer (* init cache *)
  218.     END
  219.   ELSE (* create new text *)
  220.     NEW (Q);
  221.     Q.fnt := NIL; Q.col := 0; Q.voff := 0; Q.f := WFile;
  222.     Q.off := 0; Q.len := 1; Q.next := Q; Q.prev := Q;
  223.     T.trailer := Q; T.len := 0;
  224.     T.org := -1; T.pce := T.trailer (* init cache *)
  225.   END;
  226.   T.f := f;
  227. END Open;
  228.  
  229. (*------------------------------------*)
  230. PROCEDURE Close * ( T : Text );
  231.  
  232. BEGIN (* Close *)
  233.   IF T.f # NIL THEN Files.Close (T.f) END
  234. END Close;
  235.  
  236. (*------------------------------------*)
  237. PROCEDURE OpenBuf * (B : Buffer);
  238.  
  239. BEGIN (* OpenBuf *)
  240.   NEW (B.header); (* null piece *)
  241.   B.last := B.header; B.len := 0
  242. END OpenBuf;
  243.  
  244. (*------------------------------------*)
  245. PROCEDURE FindPiece
  246.   ( T       : Text;
  247.     pos     : LONGINT;
  248.     VAR org : LONGINT;
  249.     VAR p   : Piece );
  250.  
  251.   VAR n : INTEGER;
  252.  
  253. BEGIN (* FindPiece *)
  254.   IF pos < T.org THEN T.org := -1; T.pce := T.trailer END;
  255.   org := T.org; p := T.pce; (* from cache *)
  256.   n := 0;
  257.   WHILE pos >= org + p.len DO
  258.     org := org + p.len; p := p.next; INC (n)
  259.   END; (* WHILE *)
  260.   IF n > 50 THEN T.org := org; T.pce := p END;
  261. END FindPiece;
  262.  
  263. (*------------------------------------*)
  264. PROCEDURE SplitPiece ( p : Piece; off : LONGINT; VAR pr : Piece );
  265.  
  266.   VAR q : Piece;
  267.  
  268. BEGIN (* SplitPiece *)
  269.   IF off > 0 THEN
  270.     NEW (q);
  271.     q.fnt := p.fnt; q.col := p.col; q.voff := p.voff; q.len := p.len - off;
  272.     q.f := p.f; q.off := p.off + off;
  273.     p.len := off;
  274.     q.next := p.next; p.next := q;
  275.     q.prev := p; q.next.prev := q;
  276.     pr := q
  277.   ELSE
  278.     pr := p
  279.   END; (* ELSE *)
  280. END SplitPiece;
  281.  
  282. (*------------------------------------*)
  283. PROCEDURE OpenReader * ( VAR R : Reader; T : Text; pos : LONGINT );
  284.  
  285.   VAR p : Piece; org : LONGINT;
  286.  
  287. BEGIN (* OpenReader *)
  288.   FindPiece (T, pos, org, p);
  289.   R.ref := p; R.org := org; R.off := pos - org;
  290.   Files.Set (R, R.ref.f, R.ref.off + R.off); R.eot := FALSE;
  291. END OpenReader;
  292.  
  293. (*------------------------------------*)
  294. PROCEDURE Read * ( VAR R : Reader; VAR ch : CHAR );
  295.  
  296. BEGIN (* Read *)
  297.   Files.Read (R, ch); IF ch = LF THEN ch := CR END;
  298.   R.fnt := R.ref.fnt; R.col := R.ref.col;
  299.   R.voff := R.ref.voff; INC (R.off);
  300.   IF R.off = R.ref.len THEN
  301.     IF R.ref.f = WFile THEN R.eot := TRUE END;
  302.     R.org := R.org + R.off; R.off := 0;
  303.     R.ref := R.ref.next;
  304.     R.org := R.org + R.off; R.off := 0;
  305.     Files.Set (R, R.ref.f, R.ref.off)
  306.   END; (* IF *)
  307. END Read;
  308.  
  309. (*------------------------------------*)
  310. PROCEDURE Pos * ( VAR R : Reader ) : LONGINT;
  311.  
  312. BEGIN (* Pos *)
  313.   RETURN R.org + R.off
  314. END Pos;
  315.  
  316. (*------------------------------------*)
  317. PROCEDURE Store *
  318.   ( T       : Text;
  319.     f       : Files.File;
  320.     pos     : LONGINT;
  321.     VAR len : LONGINT );
  322.  
  323.   VAR
  324.     p, q : Piece;
  325.     R : Reader; W : Files.Rider;
  326.     off, rlen : LONGINT; id : INTEGER;
  327.     N, n : SHORTINT; ch : CHAR;
  328.     Dict : ARRAY 32 OF Fonts.Name;
  329.  
  330. BEGIN (* Store *)
  331.   Files.Set (W, f, pos);
  332.   id := TextBlockId; Files.WriteBytes (W, id, SIZE (INTEGER));
  333.   Files.WriteBytes (W, off, SIZE (LONGINT)); (* place holder *)
  334.   N := 1;
  335.   p := T.trailer.next;
  336.   WHILE p # T.trailer DO
  337.     rlen := p.len; q := p.next;
  338.     WHILE
  339.       (q # T.trailer)
  340.       & (q.fnt = p.fnt) & (q.col = p.col) & (q.voff = p.voff)
  341.     DO
  342.       rlen := rlen + q.len; q := q.next;
  343.     END; (* WHILE *)
  344.     Dict [N] := p.fnt.name; n := 1;
  345.     WHILE Dict [n] # p.fnt.name DO INC (n) END;
  346.     Files.Write (W, n);
  347.     IF n = N THEN WriteName (W, p.fnt.name); INC (N) END;
  348.     Files.Write (W, p.col); Files.Write (W, p.voff);
  349.     Files.WriteBytes (W, rlen, SIZE (LONGINT));
  350.     p := q
  351.   END; (* WHILE *)
  352.   Files.Write (W, 0); Files.WriteBytes (W, T.len, SIZE (LONGINT));
  353.   off := Files.Pos (W);
  354.   OpenReader (R, T, 0); Read (R, ch);
  355.   WHILE ~R.eot DO Files.Write (W, ch); Read (R, ch) END;
  356.   Files.Set (W, f, pos + SIZE (INTEGER));
  357.   Files.WriteBytes (W, off, SIZE (LONGINT)); (* fixup *)
  358.   len := off + T.len - pos
  359. END Store;
  360.  
  361. (*------------------------------------*)
  362. PROCEDURE Save * ( T : Text; beg, end : LONGINT; B : Buffer );
  363.  
  364.   VAR
  365.     p, q, qb, qe : Piece;
  366.     org : LONGINT;
  367.  
  368. BEGIN (* Save *)
  369.   IF end > T.len THEN end := T.len END;
  370.   FindPiece (T, beg, org, p);
  371.   NEW (qb);
  372.   qb^ := p^; qb.len := qb.len - (beg - org);
  373.   qb.off := qb.off + (beg - org);
  374.   qe := qb;
  375.   WHILE end > org + p.len DO
  376.     org := org + p.len; p := p.next;
  377.     NEW (q);
  378.     q^ := p^; qe.next := q; q.prev := qe; qe := q
  379.   END; (* WHILE *)
  380.   qe.next := NIL; qe.len := qe.len - (org + p.len - end);
  381.   B.last.next := qb; qb.prev := B.last; B.last := qe;
  382.   B.len := B.len + (end - beg)
  383. END Save;
  384.  
  385. (*------------------------------------*)
  386. PROCEDURE Copy * ( SB, DB : Buffer );
  387.  
  388.   VAR Q, q, p : Piece;
  389.  
  390. BEGIN (* Copy *)
  391.   p := SB.header; Q := DB.last;
  392.   WHILE p # SB.last DO
  393.     p := p.next;
  394.     NEW (q);
  395.     q^ := p^; Q.next := q; q.prev := Q; Q := q
  396.   END; (* WHILE *)
  397.   DB.last := Q; DB.len := DB.len + SB.len
  398. END Copy;
  399.  
  400. (*------------------------------------*)
  401. PROCEDURE ChangeLooks *
  402.   ( T         : Text;
  403.     beg, end  : LONGINT;
  404.     sel       : SET;
  405.     fnt       : Fonts.Font;
  406.     col, voff : SHORTINT );
  407.  
  408.   VAR
  409.     pb, pe, p : Piece;
  410.     org : LONGINT;
  411.  
  412. BEGIN (* ChangeLooks *)
  413.   IF end > T.len THEN end := T.len END;
  414.   FindPiece (T, beg, org, p); SplitPiece (p, beg - org, pb);
  415.   FindPiece (T, end, org, p); SplitPiece (p, end - org, pe);
  416.   p := pb;
  417.   REPEAT
  418.     IF 0 IN sel THEN p.fnt := fnt END;
  419.     IF 1 IN sel THEN p.col := col END;
  420.     IF 2 IN sel THEN p.voff := voff END;
  421.   UNTIL p = pe;
  422.   T.notify (T, replace, beg, end)
  423. END ChangeLooks;
  424.  
  425. (*------------------------------------*)
  426. PROCEDURE Insert * ( T : Text; pos : LONGINT; B : Buffer );
  427.  
  428.   VAR
  429.     pl, pr, p, qb, qe : Piece;
  430.     org, end : LONGINT;
  431.  
  432. BEGIN (* Insert *)
  433.   FindPiece (T, pos, org, p); SplitPiece (p, pos - org, pr);
  434.   IF T.org >= org THEN (* adjust cache *)
  435.     T.org := org - p.prev.len; T.pce := p.prev
  436.   END; (* IF *)
  437.   pl := pr.prev;
  438.   qb := B.header.next;
  439.   IF
  440.     (qb # NIL) & (qb.f = pl.f) & (qb.off = pl.off + pl.len)
  441.     & (qb.fnt = pl.fnt) & (qb.col = pl.col) & (qb.voff = pl.voff)
  442.   THEN
  443.     pl.len := pl.len + qb.len; qb := qb.next
  444.   END; (* IF *)
  445.   IF qb # NIL THEN
  446.     qe := B.last;
  447.     qb.prev := pl; pl.next := qb; qe.next := pr; pr.prev := qe
  448.   END; (* IF *)
  449.   T.len := T.len + B.len; end := pos + B.len;
  450.   B.last := B.header; B.last.next := NIL; B.len := 0;
  451.   T.notify (T, insert, pos, end)
  452. END Insert;
  453.  
  454. (*------------------------------------*)
  455. PROCEDURE Append * ( T : Text; B : Buffer );
  456.  
  457. BEGIN (* Append *)
  458.   Insert (T, T.len, B)
  459. END Append;
  460.  
  461. (*------------------------------------*)
  462. PROCEDURE Delete * ( T : Text; beg, end : LONGINT );
  463.  
  464.   VAR
  465.     pb, pe, pbr, per : Piece;
  466.     orgb, orge : LONGINT;
  467.  
  468. BEGIN (* Delete *)
  469.   IF end > T.len THEN end := T.len END;
  470.   FindPiece (T, beg, orgb, pb); SplitPiece (pb, beg - orgb, pbr);
  471.   FindPiece (T, end, orge, pe); SplitPiece (pe, end - orge, per);
  472.   IF T.org >= orgb THEN (* adjust cache *)
  473.     T.org := orgb - pb.prev.len; T.pce := pb.prev
  474.   END; (* IF *)
  475.   DelBuf.header.next := pbr; DelBuf.last := per.prev;
  476.   DelBuf.last.next := NIL; DelBuf.len := end - beg;
  477.   per.prev := pbr.prev;
  478.   pbr.prev.next := per;
  479.   T.len := T.len - DelBuf.len;
  480.   T.notify (T, delete, beg, end)
  481. END Delete;
  482.  
  483. (*------------------------------------*)
  484. PROCEDURE Recall ( VAR B : Buffer ); (* deleted text *)
  485.  
  486. BEGIN (* Recall *)
  487.   B := DelBuf; NEW (DelBuf); OpenBuf (DelBuf)
  488. END Recall;
  489.  
  490. (*------------------------------------*)
  491. PROCEDURE OpenScanner * ( VAR S : Scanner; T : Text; pos : LONGINT );
  492.  
  493. BEGIN (* OpenScanner *)
  494.   OpenReader (S, T, pos); S.line := 0; Read (S, S.nextCh)
  495. END OpenScanner;
  496.  
  497. (*------------------------------------*)
  498. PROCEDURE Scan * ( VAR S : Scanner );
  499.  
  500.   CONST
  501.     maxD = 32;
  502.     (* Limits for exponents *)
  503.     MaxNegD = 20; (* LONGREAL : Motorola FFP reals *)
  504.     MaxPosD = 18;
  505.     MaxNegE = 20; (* REAL : Motorola FFP reals *)
  506.     MaxPosE = 18;
  507.  
  508.   VAR
  509.     ch, term : CHAR;
  510.     neg, negE, hex : BOOLEAN;
  511.     i, j, h : SHORTINT;
  512.     e : INTEGER; k : LONGINT;
  513.     x, f : REAL; y, g : LONGREAL;
  514.     d : ARRAY maxD OF CHAR;
  515.  
  516.   (*------------------------------------*)
  517.   PROCEDURE ReadScaleFactor ();
  518.  
  519.   BEGIN (* ReadScaleFactor *)
  520.     Read (S, ch);
  521.     IF ch = "-" THEN
  522.       negE := TRUE; Read (S, ch)
  523.     ELSE
  524.       negE := FALSE; IF ch = "+" THEN Read (S, ch) END;
  525.     END;
  526.     WHILE (ch >= "0") & (ch <= "9") DO
  527.       e := e * 10 + ORD (ch) - 30H; Read (S, ch)
  528.     END; (* WHILE *)
  529.   END ReadScaleFactor;
  530.  
  531. BEGIN (* Scan *)
  532.   ch := S.nextCh; i := 0;
  533.   LOOP
  534.     IF (ch = CR) OR (ch = LF) THEN INC (S.line)
  535.     ELSIF (ch # " ") & (ch # TAB) THEN EXIT
  536.     END;
  537.     Read (S, ch)
  538.   END; (* LOOP *)
  539.   IF (CAP (ch) >= "A") & (CAP (ch) <= "Z") THEN (* name *)
  540.     REPEAT
  541.       S.s [i] := ch; INC (i); Read (S, ch)
  542.     UNTIL
  543.       (CAP (ch) > "Z")
  544.       OR (CAP (ch) < "A") & (ch > "9")
  545.       OR (ch < "0") & (ch # ".")
  546.       OR (i = 31);
  547.     S.s [i] := 0X; S.len := i; S.class := Name
  548.   ELSIF ch = 22X THEN (* literal string *)
  549.     Read (S, ch);
  550.     WHILE (ch # 22X) & (ch >= " ") & (i # 31) DO
  551.       S.s [i] := ch; INC (i); Read (S, ch)
  552.     END; (* WHILE *)
  553.     S.s [i] := 0X; S.len := i + 1; S.class := String
  554.   ELSE
  555.     IF ch = "-" THEN neg := TRUE; Read (S, ch) ELSE neg := FALSE END;
  556.     IF (ch >= "0") & (ch <= "9") THEN (* number *)
  557.       hex := FALSE; j := 0;
  558.       LOOP
  559.         d [i] := ch; INC (i); Read (S, ch);
  560.         IF ch < "0" THEN EXIT END;
  561.         IF "9" < ch THEN
  562.           IF ("A" <= ch) & (ch <= "F") THEN
  563.             hex := TRUE; ch := CHR (ORD (ch) - 7)
  564.           ELSIF ("a" <= ch) & (ch <= "f") THEN
  565.             hex := TRUE; ch := CHR (ORD (ch) - 27H)
  566.           ELSE
  567.             EXIT
  568.           END; (* ELSE *)
  569.         END; (* IF *)
  570.       END; (* LOOP *)
  571.       IF ch = "H" THEN (* hex number *)
  572.         Read (S, ch); S.class := Int;
  573.         IF i - j > 8 THEN j := i - 8 END;
  574.         k := ORD (d [j]) - 30H; INC (j);
  575.         IF (i - j = 7) & (k >= 8) THEN DEC (k, 16) END;
  576.         WHILE j < i DO k := k * 10H + (ORD (d [j]) - 30H); INC (j) END;
  577.         IF neg THEN S.i := -k ELSE S.i := k END;
  578.       ELSIF ch = "." THEN (* read real *)
  579.         Read (S, ch); h := i;
  580.         WHILE ("0" <= ch) & (ch <= "9") DO
  581.           d [i] := ch; INC (i); Read (S, ch)
  582.         END;
  583.         IF ch = "D" THEN
  584.           e := 0; y := 0.0; g := 1.0;
  585.           REPEAT y := y * 10.0 + (ORD (d [j]) - 30H); INC (j) UNTIL j = h;
  586.           WHILE j < i DO
  587.             g := g / 10.0; y := (ORD (d [j]) - 30H) * g + y; INC (j)
  588.           END;
  589.           ReadScaleFactor;
  590.           IF negE THEN
  591.             IF e <= MaxNegD THEN y := y / Reals.TenL (e) ELSE y := 0.0 END
  592.           ELSIF e > 0 THEN
  593.             IF e <= MaxPosD THEN y := y * Reals.TenL (e) ELSE HALT (40) END
  594.           END; (* IF *)
  595.           IF neg THEN y := -y END;
  596.           S.class := LongReal; S.y := y
  597.         ELSE
  598.           e := 0; x := 0.0; f := 1.0;
  599.           REPEAT x := x * 10.0 + (ORD (d [j]) - 30H); INC (j) UNTIL j = h;
  600.           WHILE j < i DO
  601.             f := f / 10.0; x := (ORD (d [j]) - 30H) * f + x; INC (j)
  602.           END;
  603.           IF ch = "E" THEN ReadScaleFactor END;
  604.           IF negE THEN
  605.             IF e <= MaxNegE THEN x := x / Reals.Ten (e) ELSE x := 0.0 END
  606.           ELSIF e > 0 THEN
  607.             IF e <= MaxPosE THEN x := x * Reals.Ten (e) ELSE HALT (40) END
  608.           END; (* IF *)
  609.           IF neg THEN x := -x END;
  610.           S.class := Real; S.x := x
  611.         END; (* ELSE *)
  612.         IF hex THEN S.class := Inval END
  613.       ELSE (* decimal integer *)
  614.         S.class := Int; k := 0;
  615.         REPEAT k := k * 10 + (ORD (d [j]) - 30H); INC (j) UNTIL j = i;
  616.         IF neg THEN S.i := -k ELSE S.i := k END;
  617.         IF hex THEN S.class := Inval ELSE S.class := Int END
  618.       END; (* ELSE *)
  619.     ELSE
  620.       S.class := Char;
  621.       IF neg THEN S.c := "-" ELSE S.c := ch; Read (S, ch) END
  622.     END; (* ELSE *)
  623.   END; (* ELSE *)
  624.   S.nextCh := ch
  625. END Scan;
  626.  
  627. (*------------------------------------*)
  628. PROCEDURE OpenWriter * ( VAR W : Writer );
  629.  
  630. BEGIN (* OpenWriter *)
  631.   NEW (W.buf); OpenBuf (W.buf); W.fnt := Fonts.Default; W.col := 1;
  632.   W.voff := 0; Files.Set (W, Files.New (""), 0)
  633. END OpenWriter;
  634.  
  635. (*------------------------------------*)
  636. PROCEDURE CloseWriter * ( VAR W : Writer );
  637.  
  638. BEGIN (* CloseWriter *)
  639.   Files.Purge (Files.Base (W))
  640. END CloseWriter;
  641.  
  642. (*------------------------------------*)
  643. PROCEDURE SetFont * ( VAR W : Writer; fnt : Fonts.Font );
  644.  
  645. BEGIN (* SetFont *)
  646.   W.fnt := fnt
  647. END SetFont;
  648.  
  649. (*------------------------------------*)
  650. PROCEDURE SetColor * ( VAR W : Writer; col : SHORTINT );
  651.  
  652. BEGIN (* SetColor *)
  653.   W.col := col
  654. END SetColor;
  655.  
  656. (*------------------------------------*)
  657. PROCEDURE SetOffset * ( VAR W : Writer; voff : SHORTINT );
  658.  
  659. BEGIN (* SetOffset *)
  660.   W.voff := voff
  661. END SetOffset;
  662.  
  663. (*------------------------------------*)
  664. PROCEDURE Write * ( VAR W : Writer; ch : CHAR );
  665.  
  666.   VAR p : Piece;
  667.  
  668. BEGIN (* Write *)
  669.   IF
  670.     (W.buf.last.fnt # W.fnt) OR (W.buf.last.col # W.col)
  671.     OR (W.buf.last.voff # W.voff)
  672.   THEN
  673.     NEW (p);
  674.     p.f := Files.Base (W); p.off := Files.Pos (W); p.len := 0;
  675.     p.fnt := W.fnt; p.col := W.col; p.voff := W.voff;
  676.     p.next := NIL; W.buf.last.next := p;
  677.     p.prev := W.buf.last; W.buf.last := p
  678.   END; (* IF *)
  679.   Files.Write (W, ch);
  680.   INC (W.buf.last.len); INC (W.buf.len)
  681. END Write;
  682.  
  683. (*------------------------------------*)
  684. PROCEDURE WriteLn * ( VAR W : Writer );
  685.  
  686. BEGIN (* WriteLn *)
  687.   Write (W, CR)
  688. END WriteLn;
  689.  
  690. (*------------------------------------*)
  691. (* $D- disable copying of open arrays *)
  692. PROCEDURE WriteString * ( VAR W : Writer; s : ARRAY OF CHAR );
  693.  
  694.   VAR i : LONGINT;
  695.  
  696. BEGIN (* WriteString *)
  697.   i := 0; WHILE s [i] # 0X DO Write (W, s [i]); INC (i) END
  698. END WriteString;
  699.  
  700. (*------------------------------------*)
  701. PROCEDURE WriteInt * ( VAR W : Writer; x, n : LONGINT );
  702.  
  703.   VAR i : INTEGER; x0 : LONGINT; a : ARRAY 11 OF CHAR;
  704.  
  705. BEGIN (* WriteInt *)
  706.   i := 0;
  707.   IF x < 0 THEN
  708.     IF x = MIN (LONGINT) THEN
  709.       WriteString (W, " -2147483648"); RETURN
  710.     ELSE
  711.       DEC (n); x0 := -x
  712.     END; (* ELSE *)
  713.   ELSE
  714.     x0 := x
  715.   END; (* ELSE *)
  716.   REPEAT
  717.     a [i] := CHR (x0 MOD 10 + 30H); x0 := x0 DIV 10; INC (i)
  718.   UNTIL x0 = 0;
  719.   WHILE n > i DO Write (W, " "); DEC (n) END;
  720.   IF x < 0 THEN Write (W, "-") END;
  721.   REPEAT DEC (i); Write (W, a [i]) UNTIL i = 0;
  722. END WriteInt;
  723.  
  724. (*------------------------------------*)
  725. PROCEDURE WriteHex * ( VAR W : Writer; x : LONGINT );
  726.  
  727.   VAR i : INTEGER; y : LONGINT; a : ARRAY 10 OF CHAR;
  728.  
  729. BEGIN (* WriteHex *)
  730.   i := 0; Write (W, " ");
  731.   REPEAT
  732.     y := x MOD 10H;
  733.     IF y < 10 THEN a [i] := CHR (y + 30H) ELSE a [i] := CHR (y + 37H) END;
  734.     x := x DIV 10H; INC (i)
  735.   UNTIL i = 8;
  736.   REPEAT DEC (i); Write (W, a [i]) UNTIL i = 0
  737. END WriteHex;
  738.  
  739. (*------------------------------------*)
  740. PROCEDURE WriteReal * ( VAR W : Writer; x : REAL; n : INTEGER );
  741.  
  742.   VAR e : INTEGER; x0 : REAL; d : ARRAY maxD OF CHAR;
  743.  
  744. BEGIN (* WriteReal *)
  745.   (*
  746.    * This implementation uses Motorola FFP format reals instead of IEEE
  747.    * single-precision reals.  The Project Oberon code has been modified to
  748.    * remove the special-case handling of unnormal and NaN values and assume
  749.    * 7-bit exponents instead of 8-bit.
  750.    *)
  751.   e := Reals.Expo (x);
  752.   IF n <= 9 THEN n := 3 ELSE DEC (n, 6) END;
  753.   REPEAT Write (W, " "); DEC (n) UNTIL n <= 8;
  754.   (* there are 2 < n <= 8 digits to be written *)
  755.   IF x < 0.0 THEN Write (W, "-"); x := -x ELSE Write (W, " ") END;
  756.   e := (e - 64) * 77 DIV 256;
  757.   IF e >= 0 THEN x := x / Reals.Ten (e) ELSE x := Reals.Ten (-e) * x END;
  758.   IF x >= 10.0 THEN x := 0.1 * x; INC (e) END;
  759.   x0 := Reals.Ten (n - 1); x := x0 * x + 0.5;
  760.   IF x >= 10.0 * x0 THEN x := x * 0.1; INC (e) END;
  761.   Reals.Convert (x, n, d);
  762.   DEC (n); Write (W, d [n]); Write (W, ".");
  763.   REPEAT DEC (n); Write (W, d [n]) UNTIL n = 0;
  764.   Write (W, "E");
  765.   IF e < 0 THEN Write (W, "-"); e := -e ELSE Write (W, "+") END;
  766.   Write (W, CHR (e DIV 10 + 30H)); Write (W, CHR (e MOD 10 + 30H))
  767. END WriteReal;
  768.  
  769. (*------------------------------------*)
  770. PROCEDURE WriteRealFix * ( VAR W : Writer; x : REAL; n, k : INTEGER );
  771.  
  772.   VAR e, i : INTEGER; sign : CHAR; x0 : REAL; d : ARRAY maxD OF CHAR;
  773.  
  774.   (*------------------------------------*)
  775.   PROCEDURE seq ( ch : CHAR; n : LONGINT );
  776.  
  777.   BEGIN (* seq *)
  778.     WHILE n > 0 DO Write (W, ch); DEC (n) END
  779.   END seq;
  780.  
  781.   (*------------------------------------*)
  782.   PROCEDURE dig (n : INTEGER);
  783.  
  784.   BEGIN (* dig *)
  785.     WHILE n > 0 DO
  786.       DEC (i); Write (W, d [i]); DEC (n)
  787.     END;
  788.   END dig;
  789.  
  790. BEGIN (* WriteRealFix *)
  791.   (*
  792.    * This implementation uses Motorola FFP format reals instead of IEEE
  793.    * single-precision reals.  The Project Oberon code has been modified to
  794.    * remove the special-case handling of unnormal and NaN values and assume
  795.    * 7-bit exponents instead of 8-bit.
  796.    *)
  797.   IF k < 0 THEN k := 0 END;
  798.   e := (Reals.Expo (x) - 64) * 77 DIV 256;
  799.   IF x < 0.0 THEN sign := "-"; x := -x ELSE sign := " " END;
  800.   IF e >= 0 THEN (* x >= 1.0, 77/256 = log 2 *) x := x / Reals.Ten (e)
  801.   ELSE (* x < 1.0 *) x := Reals.Ten (-e) * x END;
  802.   IF x >= 10.0 THEN x := 0.1 * x; INC (e) END;
  803.   (* 1 <= x < 10 *)
  804.   IF k + e >= maxD - 1 THEN k := maxD - 1 - e
  805.   ELSIF k + e < 0 THEN k := -e; x := 0.0
  806.   END;
  807.   x0 := Reals.Ten (k + e); x := x0 * x + 0.5;
  808.   IF x >= 10.0 * x0 THEN INC (e) END;
  809.   (* e = no. of digits before decimal point *)
  810.   INC (e); i := k + e; Reals.Convert (x, i, d);
  811.   IF e > 0 THEN
  812.     seq (" ", n - e - k - 2); Write (W, sign); dig (e); Write (W, ".");
  813.     dig (k)
  814.   ELSE
  815.     seq (" ", n - k - 3); Write (W, sign); Write (W, "0"); Write (W, ".");
  816.     seq ("0", -e); dig (k + e)
  817.   END; (* ELSE *)
  818. END WriteRealFix;
  819.  
  820. (*------------------------------------*)
  821. PROCEDURE WriteRealHex * ( VAR W : Writer; x : REAL );
  822.  
  823.   VAR i : INTEGER; d : ARRAY 8 OF CHAR;
  824.  
  825. BEGIN (* WriteRealHex *)
  826.   Reals.ConvertH (x, d); i := 0;
  827.   REPEAT Write (W, d [i]); INC (i) UNTIL i = 8
  828. END WriteRealHex;
  829.  
  830. (*------------------------------------*)
  831. PROCEDURE WriteLongReal * ( VAR W : Writer; x : LONGREAL; n : INTEGER );
  832.  
  833. BEGIN (* WriteLongReal *)
  834.   (*
  835.    * In this implementation, LONGREAL and REAL types are the same, so this
  836.    * procedure is implemented as a call to WriteReal ().
  837.    *)
  838.   WriteReal (W, SHORT (x), n)
  839. END WriteLongReal;
  840.  
  841. (*------------------------------------*)
  842. PROCEDURE WriteLongRealHex * ( VAR W : Writer; x : LONGREAL );
  843.  
  844. BEGIN (* WriteLongRealHex *)
  845.   (*
  846.    * In this implementation, LONGREAL and REAL types are the same, so this
  847.    * procedure is implemented as a call to WriteRealHex ().
  848.    *)
  849.   WriteRealHex (W, SHORT (x))
  850. END WriteLongRealHex;
  851.  
  852. (*------------------------------------*)
  853. PROCEDURE WriteDate * ( VAR W : Writer; t, d : LONGINT );
  854.  
  855.   (*------------------------------------*)
  856.   PROCEDURE WritePair (ch : CHAR; x : LONGINT);
  857.  
  858.   BEGIN (* WritePair *)
  859.     Write (W, ch);
  860.     Write (W, CHR (x DIV 10 + 30H)); Write (W, CHR (x MOD 10 + 30H))
  861.   END WritePair;
  862.  
  863. BEGIN (* WriteDate *)
  864.   WritePair (" ", d MOD 32); WritePair (".", d DIV 32 MOD 16);
  865.   WritePair (".", d DIV 512 MOD 128);
  866.   WritePair (" ", t DIV 4096 MOD 32); WritePair (":", t DIV 64 MOD 64);
  867.   WritePair (":", t MOD 64)
  868. END WriteDate;
  869.  
  870. (*------------------------------------*)
  871. PROCEDURE * Cleanup ();
  872.  
  873. BEGIN (* Cleanup *)
  874.   CloseWriter (W);
  875. END Cleanup;
  876.  
  877. BEGIN (* Texts *)
  878.   NEW (DelBuf); OpenBuf (DelBuf);
  879.   OpenWriter (W); Write (W, 0X);
  880.   WFile := Files.Base (W);
  881.   SYS.SETCLEANUP (Cleanup)
  882. END Texts.
  883.  
  884. (***************************************************************************
  885.  
  886.   $Log: Texts.mod $
  887.   Revision 1.3  1994/08/08  16:42:00  fjc
  888.   Release 1.4
  889.  
  890.   Revision 1.2  1994/05/12  20:45:18  fjc
  891.   - Prepared for release
  892.  
  893. # Revision 1.1  1994/01/15  21:39:12  fjc
  894. # Start of revision control
  895. #
  896. ***************************************************************************)
  897.  
  898.